home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / sap.lisp < prev    next >
Encoding:
Text File  |  1992-02-25  |  8.9 KB  |  325 lines
  1. ;;; -*- Package: VM; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: sap.lisp,v 1.24 92/02/25 04:17:06 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains the MIPS VM definition of SAP operations.
  15. ;;;
  16. ;;; Written by William Lott.
  17. ;;;
  18. (in-package "MIPS")
  19.  
  20.  
  21. ;;;; Moves and coercions:
  22.  
  23. ;;; Move a tagged SAP to an untagged representation.
  24. ;;;
  25. (define-vop (move-to-sap)
  26.   (:args (x :scs (any-reg descriptor-reg)))
  27.   (:results (y :scs (sap-reg)))
  28.   (:note "system area pointer indirection")
  29.   (:generator 1
  30.     (loadw y x vm:sap-pointer-slot vm:other-pointer-type)))
  31.  
  32. ;;;
  33. (define-move-vop move-to-sap :move
  34.   (descriptor-reg) (sap-reg))
  35.  
  36.  
  37. ;;; Move an untagged SAP to a tagged representation.
  38. ;;;
  39. (define-vop (move-from-sap)
  40.   (:args (x :scs (sap-reg) :target sap))
  41.   (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
  42.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  43.   (:results (y :scs (descriptor-reg)))
  44.   (:note "system area pointer allocation")
  45.   (:generator 20
  46.     (move sap x)
  47.     (pseudo-atomic (ndescr)
  48.       (inst addu y alloc-tn vm:other-pointer-type)
  49.       (inst addu alloc-tn alloc-tn (vm:pad-data-block vm:sap-size))
  50.       (inst li ndescr (logior (ash (1- vm:sap-size) vm:type-bits) vm:sap-type))
  51.       (storew ndescr y 0 vm:other-pointer-type)
  52.       (storew sap y vm:sap-pointer-slot vm:other-pointer-type))))
  53. ;;;
  54. (define-move-vop move-from-sap :move
  55.   (sap-reg) (descriptor-reg))
  56.  
  57.  
  58. ;;; Move untagged sap values.
  59. ;;;
  60. (define-vop (sap-move)
  61.   (:args (x :target y
  62.         :scs (sap-reg)
  63.         :load-if (not (location= x y))))
  64.   (:results (y :scs (sap-reg)
  65.            :load-if (not (location= x y))))
  66.   (:effects)
  67.   (:affected)
  68.   (:generator 0
  69.     (move y x)))
  70. ;;;
  71. (define-move-vop sap-move :move
  72.   (sap-reg) (sap-reg))
  73.  
  74.  
  75. ;;; Move untagged sap arguments/return-values.
  76. ;;;
  77. (define-vop (move-sap-argument)
  78.   (:args (x :target y
  79.         :scs (sap-reg))
  80.      (fp :scs (any-reg)
  81.          :load-if (not (sc-is y sap-reg))))
  82.   (:results (y))
  83.   (:generator 0
  84.     (sc-case y
  85.       (sap-reg
  86.        (move y x))
  87.       (sap-stack
  88.        (storew x fp (tn-offset y))))))
  89. ;;;
  90. (define-move-vop move-sap-argument :move-argument
  91.   (descriptor-reg sap-reg) (sap-reg))
  92.  
  93.  
  94. ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
  95. ;;; descriptor passing location.
  96. ;;;
  97. (define-move-vop move-argument :move-argument
  98.   (sap-reg) (descriptor-reg))
  99.  
  100.  
  101.  
  102. ;;;; SAP-INT and INT-SAP
  103.  
  104. (define-vop (sap-int)
  105.   (:args (sap :scs (sap-reg) :target int))
  106.   (:arg-types system-area-pointer)
  107.   (:results (int :scs (unsigned-reg)))
  108.   (:result-types unsigned-num)
  109.   (:translate sap-int)
  110.   (:policy :fast-safe)
  111.   (:generator 1
  112.     (move int sap)))
  113.  
  114. (define-vop (int-sap)
  115.   (:args (int :scs (unsigned-reg) :target sap))
  116.   (:arg-types unsigned-num)
  117.   (:results (sap :scs (sap-reg)))
  118.   (:result-types system-area-pointer)
  119.   (:translate int-sap)
  120.   (:policy :fast-safe)
  121.   (:generator 1
  122.     (move sap int)))
  123.  
  124.  
  125.  
  126. ;;;; POINTER+ and POINTER-
  127.  
  128. (define-vop (pointer+)
  129.   (:translate sap+)
  130.   (:args (ptr :scs (sap-reg))
  131.      (offset :scs (signed-reg immediate)))
  132.   (:arg-types system-area-pointer signed-num)
  133.   (:results (res :scs (sap-reg)))
  134.   (:result-types system-area-pointer)
  135.   (:policy :fast-safe)
  136.   (:generator 1
  137.     (sc-case offset
  138.       (signed-reg
  139.        (inst addu res ptr offset))
  140.       (immediate
  141.        (inst addu res ptr (tn-value offset))))))
  142.  
  143. (define-vop (pointer-)
  144.   (:translate sap-)
  145.   (:args (ptr1 :scs (sap-reg))
  146.      (ptr2 :scs (sap-reg)))
  147.   (:arg-types system-area-pointer system-area-pointer)
  148.   (:policy :fast-safe)
  149.   (:results (res :scs (signed-reg)))
  150.   (:result-types signed-num)
  151.   (:generator 1
  152.     (inst subu res ptr1 ptr2)))
  153.  
  154.  
  155.  
  156. ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
  157.  
  158. (eval-when (compile eval)
  159.  
  160. (defmacro def-system-ref-and-set
  161.       (ref-name set-name sc type size &optional signed)
  162.   (let ((ref-name-c (symbolicate ref-name "-C"))
  163.     (set-name-c (symbolicate set-name "-C")))
  164.     `(progn
  165.        (define-vop (,ref-name)
  166.      (:translate ,ref-name)
  167.      (:policy :fast-safe)
  168.      (:args (object :scs (sap-reg) :target sap)
  169.         (offset :scs (unsigned-reg)))
  170.      (:arg-types system-area-pointer unsigned-num)
  171.      (:results (result :scs (,sc)))
  172.      (:result-types ,type)
  173.      (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
  174.      (:generator 5
  175.        (inst addu sap object offset)
  176.        ,@(ecase size
  177.            (:byte
  178.         (if signed
  179.             '((inst lb result sap 0))
  180.             '((inst lbu result sap 0))))
  181.          (:short
  182.           (if signed
  183.               '((inst lh result sap 0))
  184.               '((inst lhu result sap 0))))
  185.          (:long
  186.           '((inst lw result sap 0)))
  187.          (:single
  188.           '((inst lwc1 result sap 0)))
  189.          (:double
  190.           '((inst lwc1 result sap 0)
  191.             (inst lwc1-odd result sap vm:word-bytes))))
  192.        (inst nop)))
  193.        (define-vop (,ref-name-c)
  194.      (:translate ,ref-name)
  195.      (:policy :fast-safe)
  196.      (:args (object :scs (sap-reg)))
  197.      (:arg-types system-area-pointer
  198.              (:constant ,(if (eq size :double)
  199.                      ;; We need to be able to add 4.
  200.                      `(integer ,(- (ash 1 16))
  201.                            ,(- (ash 1 16) 5))
  202.                      '(signed-byte 16))))
  203.      (:info offset)
  204.      (:results (result :scs (,sc)))
  205.      (:result-types ,type)
  206.      (:generator 4
  207.        ,@(ecase size
  208.            (:byte
  209.         (if signed
  210.             '((inst lb result object offset))
  211.             '((inst lbu result object offset))))
  212.            (:short
  213.         (if signed
  214.             '((inst lh result object offset))
  215.             '((inst lhu result object offset))))
  216.            (:long
  217.         '((inst lw result object offset)))
  218.            (:single
  219.         '((inst lwc1 result object offset)))
  220.            (:double
  221.         '((inst lwc1 result object offset)
  222.           (inst lwc1-odd result object (+ offset vm:word-bytes)))))
  223.        (inst nop)))
  224.        (define-vop (,set-name)
  225.      (:translate ,set-name)
  226.      (:policy :fast-safe)
  227.      (:args (object :scs (sap-reg) :target sap)
  228.         (offset :scs (unsigned-reg))
  229.         (value :scs (,sc) :target result))
  230.      (:arg-types system-area-pointer unsigned-num ,type)
  231.      (:results (result :scs (,sc)))
  232.      (:result-types ,type)
  233.      (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
  234.      (:generator 5
  235.        (inst addu sap object offset)
  236.        ,@(ecase size
  237.            (:byte
  238.         '((inst sb value sap 0)
  239.           (move result value)))
  240.            (:short
  241.         '((inst sh value sap 0)
  242.           (move result value)))
  243.            (:long
  244.         '((inst sw value sap 0)
  245.           (move result value)))
  246.            (:single
  247.         '((inst swc1 value sap 0)
  248.           (unless (location= result value)
  249.             (inst move :single result value))))
  250.            (:double
  251.         '((inst swc1 value sap 0)
  252.           (inst swc1-odd value sap vm:word-bytes)
  253.           (unless (location= result value)
  254.             (inst move :double result value)))))))
  255.        (define-vop (,set-name-c)
  256.      (:translate ,set-name)
  257.      (:policy :fast-safe)
  258.      (:args (object :scs (sap-reg))
  259.         (value :scs (,sc) :target result))
  260.      (:arg-types system-area-pointer
  261.              (:constant ,(if (eq size :double)
  262.                      ;; We need to be able to add 4.
  263.                      `(integer ,(- (ash 1 16))
  264.                            ,(- (ash 1 16) 5))
  265.                      '(signed-byte 16)))
  266.              ,type)
  267.      (:info offset)
  268.      (:results (result :scs (,sc)))
  269.      (:result-types ,type)
  270.      (:generator 5
  271.        ,@(ecase size
  272.            (:byte
  273.         '((inst sb value object offset)
  274.           (move result value)))
  275.            (:short
  276.         '((inst sh value object offset)
  277.           (move result value)))
  278.            (:long
  279.         '((inst sw value object offset)
  280.           (move result value)))
  281.            (:single
  282.         '((inst swc1 value object offset)
  283.           (unless (location= result value)
  284.             (inst move :single result value))))
  285.            (:double
  286.         '((inst swc1 value object offset)
  287.           (inst swc1-odd value object (+ offset vm:word-bytes))
  288.           (unless (location= result value)
  289.             (inst move :double result value))))))))))
  290.  
  291. ); eval-when (compile eval)
  292.  
  293. (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
  294.   unsigned-reg positive-fixnum :byte nil)
  295. (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
  296.   signed-reg tagged-num :byte t)
  297. (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
  298.   unsigned-reg positive-fixnum :short nil)
  299. (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
  300.   signed-reg tagged-num :short t)
  301. (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
  302.   unsigned-reg unsigned-num :long nil)
  303. (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
  304.   signed-reg signed-num :long t)
  305. (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
  306.   sap-reg system-area-pointer :long)
  307. (def-system-ref-and-set sap-ref-single %set-sap-ref-single
  308.   single-reg single-float :single)
  309. (def-system-ref-and-set sap-ref-double %set-sap-ref-double
  310.   double-reg double-float :double)
  311.  
  312.  
  313. ;;; Noise to convert normal lisp data objects into SAPs.
  314.  
  315. (define-vop (vector-sap)
  316.   (:translate vector-sap)
  317.   (:policy :fast-safe)
  318.   (:args (vector :scs (descriptor-reg)))
  319.   (:results (sap :scs (sap-reg)))
  320.   (:result-types system-area-pointer)
  321.   (:generator 2
  322.     (inst addu sap vector
  323.       (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))))
  324.  
  325.